perm filename MKCON[G,BGB] blob
sn#050723 filedate 1973-06-27 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00022 PAGES
00200 C REC PAGE DESCRIPTION
00300 C00001 00001
00400 C00004 00002 TITLE MKCON - MAKE CONTOUR IMAGE - APRIL 1973 - B. G. BAUMGART.
00500 C00005 00003 SUBR(MKCON)Q1,Q2. MAKE: CONTOUR IMAGE FROM VIDEO.
00600 C00007 00004 SUBRS: MAKE: MKIMAG(FILM). MKLEVL(IMAGE,CUT).
00700 C00009 00005 SUBRS: MAKE: THRESH(CUT). PAXOR.
00800 C00011 00006 SUBR(MKPGON)LEVEL MAKE: POLYGON BY TRACING BIT RASTER BLOB.
00900 C00013 00007 MAKE: MKPGON SUB-OPERATIONS.
01000 C00014 00008 MAKE: THE ALCHEMIST OF MKPGON.
01100 C00017 00009 SUBR(VICONT)LEVEL CONTRAST: VECTOR INTENSITY CONTRAST.
01200 C00020 00010 CONTRAST: VICONT CONTINUED.
01300 C00023 00011 SUBR(ARCONT)LEVEL CONTRAST: ARC CONTRAST.
01400 C00025 00012 SUBR(MKSKY)LEVEL NESTING: MAKE BORDER POLYGON & SKY ARRAY.
01500 C00028 00013 SUBRS: NESTING: MKTREEATTACHDETACH
01600 C00031 00014 SUBR(INTREE)P1. NESTING: PUT POLYGON INTO THE TREE.
01700 C00033 00015 NESTING: INTREE CONTINUED.
01800 C00035 00016 SUBR(INSKY)PGON NESTING: PUT A POLYGON IN THE SKY ARRAY.
01900 C00037 00017 SUBR(KILVIC)LEVEL. KILL: CONTOURS OF THE PREVIOUS LEVEL.
02000 C00038 00018 SUBR(KLBABY)LEVEL KILL: BABY POLYGONS OF A LEVEL.
02100 C00040 00019 SUBR(KLPGON)PGN KILL: POLYGON AND RETURN CCW(PGN).
02200 C00042 00020 SUBR(SMOOTH)LEVEL SMOOTH: CONTOURS INTO ARCS.
02300 C00044 00021 MKARCS(V1,V2). SMOOTH: MAKE ARCS FROM V1 CCW TO V2.
02400 C00047 00022 SUBR(HISTOG) MISC: MAKE HISTOGRAM OF TVBUF.
02500 C00052 ENDMK
02600 C⊗;
00100 TITLE MKCON - MAKE CONTOUR IMAGE - APRIL 1973 - B. G. BAUMGART.
00200
00300 EXTERN PUTSKY,GETSKY
00400 EXTERN FLGHIS,ARCWID,CTRL,META
00500 EXTERN PAC,STADPY,TVBUF
00600 EXTERN HISTO,HSEG,VSEG,FILM
00700 EXTERN ROWPTR,COLPTR,DPYIMG
00800 EXTERN MKNODD,KLNODD,RINGIN
00900 EXTERN SQRT
01000
01100 DECLARE{IMAGE,LEVEL,POLYGON}
01200
01300 ;ENABLE SUBROUTINE FLAGS.
01400 INTERN ENEST,ECONT,ESMOO,ECOMP
01500 ENEST:-1 ;POLYGON NESTING.
01600 ECONT:-1 ;VECTOR AND ARC CONTRAST.
01700 ESMOO:-1 ;MAKE ARC SMOOTHING.
01800 ECOMP:-1 ;IMAGE COMPARING.
00100 SUBR(MKCON)Q1,Q2. MAKE: CONTOUR IMAGE FROM VIDEO.
00200 BEGIN MKCON;---------------------------------------------------
00300
00400 ;BIT POSITIONS OF THE ARGUMENTS Q1 & Q2 ENABLE INTENSITY CUTS.
00500 LAC 1,ARG2↔DAC 1,Q0
00600 LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1
00700 DZM CUT#
00800
00900 ;MAKE THE IMAGE BLOCK AND THE LEVEL -1 FRAME POLYGON.
01000 SETQ IMAGE,{MKIMAG,FILM}
01100 SETQ LEVEL,{MKLEVL,IMAGE,[-1]}
01200 SETQ POLYGON,{MKSKY,LEVEL} ;BORDER & SKY.
01300
01400 ;FIND AN INTENSITY CONTOUR ENABLE BIT.
01500 L0: LAC 0,Q0↔LAC 1,Q1
01600 L1: AOS 2,CUT↔LSHC 0,1↔JUMPL 0,L2
01700 CAMN 0,1↔JUMPE 0,L5↔GO L1
01800
01900 ;THRESHOLD THE TVBUF
02000 L2: DAC 0,Q0↔DAC 1,Q1
02100 CALL(THRESH,CUT)
02200 CALL(PACXOR)
02300
02400 ;MAKE LEVEL NODE WITH A RING OF POLYGON NODES.
02500 SETQ(LEVEL,{MKLEVL,IMAGE,CUT})
02600 L3: SETQ(POLYGON,{MKPGON,LEVEL})
02700 JUMPN 1,L3↔LAC 1,LEVEL↔SON 1,1↔JUMPE 1,L0
02800
02900 ;LEVEL OPERATIONS.
03000 L4: CALL(VICONT,LEVEL)
03100 CALL(KLBABY,LEVEL)
03200 CALL(SMOOTH,LEVEL)
03300 CALL(ARCONT,LEVEL)
03400 CALL(MKTREE,LEVEL)
03500 CALL(KILVIC,LEVEL)
03600 CALL(STADPY)
03700 GO L0
03800
03900 ;LAGGING LEVEL OPERATIONS.
04000 L5: LAC 1,LEVEL↔CCW 1,1↔DAC 1,LEVEL
04100 CALL(KILVIC,LEVEL)
04200 LAC 1,IMAGE↔POP2J
04300
04400 DECLARE{Q0,Q1}
04500 BEND MKCON; BGB 6 DECEMBER 1972 ----------------------------------
00100 ; SUBRS: MAKE: MKIMAG(FILM). MKLEVL(IMAGE,CUT).
00200 SUBR(MKIMAG)FILM--------------------------------------------------
00300 BEGIN MKIMAG; MAKE IMAGE NODE - BGB - 10 JANUARY 1973.
00400 EXTERN QIMAGE
00500 SETQ(IMAGE,{MKNODD,[IBIT+IMGREL]})
00600 CALL(RINGIN,IMAGE,FILM)
00700 LAC 1,IMAGE↔CW 2,1 ;PREVIOUS IMAGE.
00800 NCNT 2,2↔AOS 2↔NCNT. 2,1 ;IMAGE SEQUENCE NUMBER.
00900 DAC 1,QIMAGE
01000 POP1J
01100 BEND;1/10/73------------------------------------------------------
01200
01300 SUBR(MKLEVL)IMAGE,CUT---------------------------------------------
01400 BEGIN MKLEVL; MAKE LEVEL NODE - BGB - 10 JANUARY 1973.
01500 SETQ(LEVEL,{MKNODD,[LBIT+LVLREL]})
01600 CALL(RINGIN,LEVEL,IMAGE)
01700 LAC 1,LEVEL↔LAC 2,ARG2
01800 LAC 0,ARG1↔NCNT. 0,1
01900 POP2J
02000 BEND;1/10/73------------------------------------------------------
00100 ; SUBRS: MAKE: THRESH(CUT). PAXOR.
00200 SUBR(THRESH)------------------------------------------------------
00300 BEGIN THRESH
00400 ;SOUTH TO PAC FOR PIXELS ≥ CUT.
00500 I←13 ↔ J←14
00600 LAC [XWD L,2]↔BLT 13
00700 LAP 5,ARG1
00800 GO 3
00900
01000 ;ACCUMULATOR LOOP.
01100 L: POINT 6,TVBUF,-1
01200 MOVEI J,=36 ;3
01300 ILDB 2 ;4
01400 SUBI ;CUT ;5
01500 ROTC 1 ;6
01600 SOJG J,4 ;7
01700 SETCAM 1,PAC(I) ;10
01800 AOBJN I,3 ;11
01900 POP1J ;12
02000 XWD -=1728,0 ;13
02100 BEND THRESH;BGB 4 DECEMBER 1972 ----------------------------------
02200
02300
02400 ;PACXOR. ROOK'S MOVE XOR'ING ON 1-BIT IMAGE.
02500 SUBR(PACXOR)------------------------------------------------------
02600 BEGIN PACXOR
02700 I←2
02800 SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
02900 SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
03000 SETZ I,
03100 HRRI PAC↔DAP L+2
03200 L: TRNN I,7↔SETZ 1,↔LAC PAC(I)
03300 XORM HSEG+8(I) ;HSEG's are above PAC bits.
03400 ROTC -1↔ROT 1,1
03500 XORM VSEG(I) ;VSEG's are left of PAC bits.
03600 AOS I
03700 CAIE I,=1728
03800 GO L
03900 POP0J
04000 BEND PACXOR; BGB 4 DECEMBER 1972 ---------------------------------
00100 SUBR(MKPGON)LEVEL MAKE: POLYGON BY TRACING BIT RASTER BLOB.
00200 BEGIN MKPGON;------------------------------------------------------
00300
00400 ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00500 LAC 1,ARG1↔NCNT H1,1↔LSH H1,-3
00600 LACI H2,7↔SUB H2,H1
00700 LAC I,ISAVED#↔CDR PTR,ARG1↔LACI BITQ,VREL
00800 SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00900
01000 ;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01100 L1: SKIPE 1,VSEG(I)↔GO L2
01200 AOS I↔CAIE I,=1728↔GO L1
01300 SETZB 1,ISAVED#↔POP1J ;PAC IS NOW EMPTY.
01400
01500 L2: DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01600 MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01700 LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2 ;COLUMN.
01800 LAC I↔LSH -3↔DIP RC.↔LSH RC.,6 ;ROW.
01900
02000 ;DISTINGUISH BLOBS FROM HOLES.
02100 DZM HOLE#
02200 TDNN MASK,@PACPTR ;HOLE OR BLOB ?
02300 SETOM HOLE# ;HOLE'A'COMING.
02400 SKIPE HOLE↔EXCH H1,H2
02500
02600 ;AND HEAD SOUTH.
02700
02800 SETQ(PG,{MKNODD,[PBIT+PGNREL]})
02900 LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
03000 SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03100 DAC RC.,RCMIN#
03200 DZM RCMAX#
03300 SETZ V,↔DZM ECNT#
03400 PUSHJ P,FOLLOW
03500 LAC V,V0
03600 CCW. V,E↔CW. E,V
03700
03800 ;MAKE & RETURN VIC POLYGON.
03900
04000 LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04100 NCNT. 1,PG
04200 LAC V0↔SON. 0,PG ;UPPER MOST LEFT.
04300 LAC V1↔ARC. 0,PG ;LOWER MOST RIGHT.
04400 LAC 1,PG
04500 L3: POP1J
00100 ; MAKE: MKPGON SUB-OPERATIONS.
00200
00300 DEFINE TRY (SEG,YES) {
00400 LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500 DEFINE LEFT {SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600 DEFINE RIGHT {ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700 DEFINE UP {SUB RC.,[1B11]↔SUBI I,8}
00800 DEFINE DOWN {ADD RC.,[1B11]↔ADDI I,8}
00900
01000 ;CREATE NEW EDGE AND VERTEX OF A VIC.
01100 TURN: 0
01200 AOS TURNS#
01300 ADD D,RC.
01400 AOS 2,ECNT
01500
01600 ;VERTEX
01700 CALL(MKNODD,BITQ)
01800 DAD. PG,1
01900 SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000 DAC 1,V
02100 CCW. V,E↔CW. E,V
02200 T2: DAC D,RC(V)
02300 CAMLE D,RCMAX
02400 GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02500 DAC V,E
02600 GO @TURN
00100 ; MAKE: THE ALCHEMIST OF MKPGON.
00200 ;converts bits of lead into lines of gold.
00300
00400 NORTH: ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
00500 NORTH2: LEFT↔LAC D,DELPM(H1)↔TRY HSEG,WEST
00600 RIGHT↔UP↔TRY VSEG,NORTH2
00700 DOWN↔LAC D,DELPP(H2)↔TRY HSEG,EAST↔FATAL(NORTH)
00800 NORTH3: LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00900 NORTH4: UP↔LAC D,DELPM(H1)↔TRY HSEG,WEST↔GO NORTH4
01000
01100
01200 WEST: ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
01300 WEST2: CAMN RC.,RCMIN↔POPJ P,
01400 FOLLOW: LAC D,DELPP(H1)↔TRY VSEG,SOUTH
01500 LEFT↔TRY HSEG,WEST2
01600 RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01700
01800
01900 SOUTH: LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
02000 SOUTH2: DOWN↔LAC D,DELMP(H1)
02100 CAR RC.↔CAIN =216B29↔GO EAST3
02200 TRY HSEG, EAST↔TRY VSEG,SOUTH2
02300 LEFT↔LAC D,DELMM(H2)↔TRY HSEG,WEST↔FATAL(SOUTH)
02400
02500
02600 EAST: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
02700 EAST2: RIGHT↔LAC D,DELMM(H1)
02800 CDR RC.↔CAIN =288B29↔GO NORTH3
02900 UP↔TRY VSEG,NORTH
03000 DOWN↔TRY HSEG,EAST2
03100 LAC D,DELPM(H2)↔TRY VSEG,SOUTH↔FATAL(EAST)
03200 EAST3: LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300 EAST4: RIGHT↔LAC D,DELMM(H1)
03400 CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500 TRY VSEG,NORTH↔GO EAST4
03600
03700 ;DEKINKING OFF SETS.
03800
03900 DELPP: FOR I←24,33{XWD I,I↔}
04000 DELPM: FOR I←24,33{XWD I,-I↔}
04100 DELMP: FOR I←24,33{XWD -I,I↔}
04200 DELMM: FOR I←24,33{XWD -I,-I↔}
04300
04400
04500 BEND MKPGON;BGB AUGUST 1972 ---------------------------------------
00100 SUBR(VICONT)LEVEL CONTRAST: VECTOR INTENSITY CONTRAST.
00200 COMMENT ⊗
00300 The contrast of a vector is defined as (QUOTIENT (DIFFERENCE (Sum of
00400 pixel values on one side of the vector) (Sum of pixel values on the
00500 other side of the vector)) (length of the vector in pixels)). Since,
00600 vectors are always either horizontal or vertical, there are two
00700 inner most loops. For horizontal vectors two byte pointers are
00800 incremented up core west to east a row apart thru the TVBUF. For the
00900 vertical vectors one byte pointer is saved then LDB'ed and ILDB'ed,
01000 and then is restored and bumped a row by the code at line NSL:
01100 ⊗;
01200
01300 BEGIN VICONT;--------------------------------------------------------
01400 ACCUMULATORS{R1,C1,V1,R2,C2,V2,PG,SUM1,SUM2,CNT,PTR,SAVCNT}
01500 SKIPN ECONT↔POP1J
01600 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0# ;FIRST POLYGON.
01700 L1: SON V2,PG↔DAC V2,V0# ;FIRST VECTOR.
01800 ROW R2,V2↔ADDI R2,40↔LSH R2,-6
01900 COL C2,V2↔ADDI C2,40↔LSH C2,-6
02000
02100 L2: LAC V1,V2↔LAC R1,R2↔LAC C1,C2↔CCW V2,V2 ;NEXT VECTOR.
02200 ROW R2,V2↔ADDI R2,40↔LSH R2,-6
02300 COL C2,V2↔ADDI C2,40↔LSH C2,-6
02400 SETZB SUM1,SUM2
02500 TESTZ V1,WESBIT↔GO WEST
02600 TESTZ V1,SOUBIT↔GO SOUTH
02700 TESTZ V1,EASBIT↔GO EAST
02800 TESTZ V1,NORBIT↔GO NORTH↔HALT
02900 L3: CAME V2,V0↔GO L2↔CCW PG,PG ;NEXT POLYGON.
03000 CAME PG,PG0↔GO L1↔POP1J ;EXIT.
03100 ;-----------------------------------------------------------------
00100 ; CONTRAST: VICONT CONTINUED.
00200 WEST: LAC ROWPTR(R2)↔ADD COLPTR-1(C2)↔TLZ 1
00300 LAC CNT,C1↔SUB CNT,C2↔CALL(EW) ;CNT ← C1-C2
00400 SUB SUM2,SUM1
00500 NTIME. SUM2,V1↔PTIME. SAVCNT,V1
00600 IDIV SUM2,SAVCNT
00700 CNTRS. SUM2,V1↔GO L3
00800 SOUTH: LAC ROWPTR(R1)↔ADD COLPTR-1(C1)↔TLZ 1
00900 LAC CNT,R2↔SUB CNT,R1↔CALL(NS) ;CNT ← R2-R1
01000 SUB SUM2,SUM1
01100 NTIME. SUM2,V1↔PTIME. SAVCNT,V1
01200 IDIV SUM2,SAVCNT
01300 CNTRS. SUM2,V1↔GO L3
01400 EAST: LAC ROWPTR(R1)↔ADD COLPTR-1(C1)↔TLZ 1
01500 LAC CNT,C2↔SUB CNT,C1↔CALL(EW) ;CNT ← C2-C1
01600 SUB SUM1,SUM2
01700 NTIME. SUM1,V1↔PTIME. SAVCNT,V1
01800 IDIV SUM1,SAVCNT
01900 CNTRS. SUM1,V1↔GO L3
02000 NORTH: LAC ROWPTR(R2)↔ADD COLPTR-1(C2)↔TLZ 1
02100 LAC CNT,R1↔SUB CNT,R2↔CALL(NS) ;CNT ← R1-R2
02200 SUB SUM1,SUM2
02300 NTIME. SUM1,V1↔PTIME. SAVCNT,V1
02400 IDIV SUM1,SAVCNT
02500 CNTRS. SUM1,V1↔GO L3
02600 DECLARE{PTRNW,PTRSE}
02700 ;-----------------------------------------------------------------
02800 ;EAST-WEST HORIZONAL VECTORS.
02900 EW: DAC CNT,SAVCNT
03000 DAC PTRSE
03100 SUBI=48↔DAC PTRNW
03200 EWL: ILDB PTRNW↔ADDM SUM1
03300 ILDB PTRSE↔ADDM SUM2
03400 SOJG CNT,EWL
03500
03600 CAIG R1,0↔SETZ SUM1,
03700 CAIL R1,=216↔SETZ SUM2,
03800 POP0J
03900
04000 ;NORTH-SOUTH VERTICAL VECTORS.
04100 NS: DAC CNT,SAVCNT↔DAC PTR↔TDCA 1,1
04200
04300 NSL: LACI 1,=48↔ADDB 1,PTR
04400 LDB 1↔ADDM SUM1
04500 ILDB 1↔ADDM SUM2
04600 SOJG CNT,NSL
04700 CAIG C1,0↔SETZ SUM1,
04800 CAIL C1,=288↔SETZ SUM2,↔POP0J
04900 BEND VICONT; BGB 14 DECEMBER 1972 --------------------------------
00100 SUBR(ARCONT)LEVEL CONTRAST: ARC CONTRAST.
00200 BEGIN ARCONT;-----------------------------------------------------
00300 ACCUMULATORS{QNS,QEW,A1,A2,V1,V2,PG,PG0,A0}
00400 SKIPN ECONT↔POP1J↔SKIPN ESMOO↔POP1J
00500 ;FOR ALL THE ARCS OF THIS LEVEL.
00600 LAC 1,ARG1
00700 SON PG,1↔DAC PG,PG0 ;FIRST POLYGON.
00800 L1: ARC A2,PG↔DAC A2,A0 ;FIRST ARC.
00900 L2: LAC A1,A2↔SON V1,A1
01000 CCW A2,A1↔SON V2,A2
01100
01200 ;ACCUMULATE VECTOR CONTRAST,,LENGTH ALONG THE ARC.
01300 SETZB QNS,QEW
01400 L3: TESTZ V1,NORBIT+SOUBIT↔GO[
01500 ADD QNS,6(V1)↔GO .+2]
01600 ADD QEW,6(V1)↔DZM 6(V1)
01700 CCW V1,V1
01800 CAME V1,V2↔GO L3
01900
02000 ;COMPUTE ARC CONTRAST: SIN↑2*VERTICAL + COS↑2*HORIZONTAL.
02100 CAR 0,QNS↔FSC 0,233
02200 CDR 1,QNS↔FSC 1,233↔FDVR 0,1
02300 HLLZ 1,6(A1)↔FMPR 0,1↔DAC 0,QNS
02400 CAR 0,QEW↔FSC 0,233
02500 CDR 1,QEW↔FSC 1,233↔FDVR 0,1
02600 HRLZ 1,6(A1)↔FMPR 0,1↔FADR 0,QNS
02700 FIX 0,233000↔CNTRS. 0,A1↔DZM 6(V1)↔DZM 6(A1)
02800
02900 CAME A2,A0↔GO L2 ;LAST ARC OF THE POLYGON ?
03000 CCW PG,PG
03100 CAME PG,PG0↔GO L1 ;LAST POLYGON OF THE LEVEL ?
03200 POP1J
03300 BEND ARCONT; 21 JANUARY 1973 -------------------------------------
00100 SUBR(MKSKY)LEVEL NESTING: MAKE BORDER POLYGON & SKY ARRAY.
00200 BEGIN MKSKY;------------------------------------------------------
00300
00400 ACCUMULATORS{R,C,N,S,E,W,M,LVL}
00500
00600 ;MAIN BORDER POLYGON.
00700 SETQ(M,{MKNODD,[PBIT+PGNREL]})
00800 LAC LVL,ARG1↔DAD. LVL,1
00900 CALL(RINGIN,M,LVL)
01000 LACI R,=216⊗6↔LACI C,=288⊗6
01100
01200 ;VERTEX-POLYGON POLYGON.
01300 SETQ(W,{MKNODD,[VBIT+SOUBIT+VREL]})↔DAD. M,W
01400 SETQ(S,{MKNODD,[VBIT+EASBIT+VREL]})↔DAD. M,S
01500 SETQ(E,{MKNODD,[VBIT+NORBIT+VREL]})↔DAD. M,E
01600 SETQ(N,{MKNODD,[VBIT+WESBIT+VREL]})↔DAD. M,N
01700 ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
01800 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
01900 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
02000 SON. W,M↔LAC 1,M
02100
02200
02300 ;PUT THE BORDER POLYGON UP IN THE SKY.
02400 CDR GETSKY↔DZM@↔DIP↔AOS
02500 CDR 1,GETSKY↔BLT ==31500-1(1)
02600 SETZ C,↔LACI R,=216↔LAC W
02700 XCT PUTSKY(R)↔SOJGE R,.-1
02800 LACI R,=216↔LACI C,=288↔LAC E
02900 XCT PUTSKY(R)↔SOJGE R,.-1
03000
03100 ;ARC BORDER POLYGON.
03200 LACI R,=216⊗6↔LACI C,=288⊗6
03300 CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,W↔SON. W,1↔LAC W,1
03400 CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,S↔SON. S,1↔LAC S,1
03500 CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,E↔SON. E,1↔LAC E,1
03600 CALL(MKNODD,[ARCBIT+VBIT+VREL])↔SON. 1,N↔SON. N,1↔LAC N,1
03700 ROW. R,S↔ROW. R,E↔COL. C,E↔COL. C,N
03800 DAD. M,W↔DAD. M,S↔DAD. M,E↔DAD. M,N
03900 CW. N,W ↔ CW. E,N ↔ CW. S,E ↔ CW. W,S
04000 CCW. S,W ↔ CCW. E,S ↔ CCW. N,E ↔ CCW. W,N
04100 ARC. W,M↔LAC 1,M↔POP1J
04200 BEND MKSKY; BGB 4 DECEMBER 1972 ----------------------------------
00100 ; SUBRS: NESTING: MKTREE;ATTACH;DETACH;
00200 SUBR(MKTREE)LEVEL
00300 BEGIN MKTREE;---------------------------------------------------
00400 SKIPN ENEST↔POP1J
00500 ;PLACE POLYGONS OF THIS LEVEL IN THE TREE AND IN THE SKY.
00600 LAC 1,ARG1↔SON 1,1↔DAC 1,PG0#↔DAC 1,POLYGON
00700 L1: CALL(INTREE,POLYGON)
00800 LAC 1,POLYGON
00900 CCW 1,1
01000 DAC 1,POLYGON
01100 CAME 1,PG0↔GO L1
01200 POP1J
01300 BEND MKTREE; BGB 19 DECEMBER 1972 --------------------------------
01400
01500 SUBR(ATTACH)P1,P2-----------------------------------------------
01600 BEGIN ATTACH;PLACE P1 WITHIN P2 - BGB - 23 JANUARY 1973.
01700 LAC 1,ARG2↔LAC 2,ARG1
01800 EXO. 2,1↔ENDO 3,2 ;EXO(P1)←P2;P3←ENDO(P);
01900 JUMPN 3,.+5 ;IF P3=0 THEN BEGIN
02000 ENDO. 1,2↔PGON. 1,1 ;ENDO(P2)←NGON(P1)←PGON(P1)←P1;
02100 NGON. 1,1↔POP2J ;RETURN;END;
02200 NGON 4,3 ;P4←NGON(P3);
02300 PGON. 1,4↔NGON. 1,3 ;PGON(P4)←NGON(P3)←P1;
02400 NGON. 4,1↔PGON. 3,1 ;NGON(P1)←P4;PGON(P1)←P3;
02500 POP2J
02600 BEND;1/23/73------------------------------------------------------
02700
02800 SUBR(DETACH)P1--------------------------------------------------
02900 BEGIN DETACH;REMOVE P1 FROM THE TREE - BGB - 23 JANUARY 1973.
03000 LAC 1,ARG1
03100 NGON 2,1↔PGON 3,1 ;P2←NGON(P1);P3←PGON(P1);
03200 PGON. 3,2↔NGON. 2,3 ;PGON(P2)←P3;NGON(P3)←P2;
03300 NGON. 1,1↔PGON. 1,1 ;NGON(P1)←PGON(P1)←P1;
03400 CAMN 3,1↔SETZ 3, ;IF P3=P1 THEN P3←NIL;
03500 EXO 2,1↔ENDO 0,2 ;P2←EXO(P1);P0←ENDO(P2);
03600 CAMN 0,1↔ENDO. 3,2 ;IF P0=P1 THEN ENDO(P2)←P3;
03700 POP1J
03800 BEND;1/23/73------------------------------------------------------
00100 SUBR(INTREE)P1. NESTING: PUT POLYGON INTO THE TREE.
00200 BEGIN INTREE;-----------------------------------------------------
00300
00400 ACCUMULATORS{R,C,E,LST,P0,P1,P2,P3}
00500 LAC P1,ARG1
00600 SON E,P1↔JUMPE E,POP1J.
00700 ROW R,(E)↔ADDI R,40↔LSH R,-6
00800 COL C,(E)↔ADDI C,40↔LSH C,-6
00900 TESTZ P1,HOLBIT↔SOS C
01000
01100 ;FIND THE VERTICAL EDGE DUE EAST OF HERE.
01200 L0: XCT GETSKY(R)↔SKIPN 1↔SOJA C,L0
01300 ANDCMI 1,%↔DAD P2,1↔CAMN P2,P1↔SOJA C,L0
01400
01500 ;PLACE P1 WITHIN P2, IN THE TREE AND IN THE SKY.
01600 TEST 1,SOUBIT↔EXO P2,P2
01700 CALL(ATTACH,P1,P2)
01800 CALL(INSKY,P1)
01900
02000 ;CONS UP LIST OF P2'S ENDO POLYGONS.
02100 LAC P1,ARG1↔HRLOI LST,0 ;LIST ← NIL.
02200 EXO P2,P1↔ENDO P3,P2↔JUMPE P3,POP1J. ;AIN'T NONE.
02300 DAC P3,P0
02400 L1: CAMN P3,P1↔GO L2
02500 PTIME. LST,P3↔LAC LST,P3 ;CONS P3 TO LIST.
02600 L2: NGON P3,P3↔CAME P3,P0↔GO L1 ;CDR THE RING.
02700
00100 ; NESTING: INTREE CONTINUED.
00200 ;SCAN LIST FOR P1 ENDO POLYGONS. P2←CDR(LIST).
00300 L3: CAIN LST,-1↔SETZ LST,
00400 SKIPN P2,LST↔POP1J↔SON E,P2
00500 ROW R,E↔ADDI R,40↔LSH R,-6
00600 COL C,E↔ADDI C,40↔LSH C,-6
00700
00800 ;SCAN FOR FIRST POLYGON TO THE EAST OF P2.
00900 L4: JUMPL C,L7
01000 XCT GETSKY(R)↔SKIPN 1↔SOJA C,L4
01100 TRNE 1,%↔GO[TRC 1,%
01200 DAD P3,1↔CAMN P3,LST↔GO L7↔GO .+4]
01300 DAD P3,1↔CAMN P3,LST↔SOJA C,L4
01400 TESTZ 1,SOUBIT↔GO L5 ;SKIP ON BRO. GO ON DAD.
01500
01600 ;IF BROTHER IS NOT ON THE P-LIST THEN EXO(P3) IS VALID.
01700 L4A: LAC P0,P3↔EXO P3,P3
01800 PTIME 0,P0↔JUMPE 0,L5
01900 ;IF BROTHER IS ON P-LIST THEN EXO(P3) IS NOT YET VALID AND MUST
02000 ;BE SAVED ON AN N-LIST.
02100 NTIME 0,P0↔NTIME. 0,P2
02200 NTIME. P2,P0↔GO L6
02300
02400 ;CHECK FOR P1 CAPTURE OF P2. P3 IS THE SKY-EXO(P2).
02500 L5: EXO 0,P2
02600 CAMN 0,P3↔GO L6 ;EXO(P2)=SKYEXO(P2).
02700 CALL(DETACH,P2)
02800 CALL(ATTACH,P2,P1)
02900
03000 ;CAPTURE OLDER BROTHER OFF THE N-LIST OF P2.
03100 L6: LAC 1,P2↔SETZ
03200 NTIME P2,P2
03300 NTIME. 0,1
03400 JUMPN P2,L5
03500
03600 ;CDR THE P-LIST OF POTENTIAL ENDO POLYGONS.
03700 L7: LAC 1,LST↔SETZ
03800 PTIME LST,LST↔PTIME. 0,1
03900 GO L3
04000 BEND INTREE; BGB 23 JANUARY 1973 ---------------------------------
00100 SUBR(INSKY)PGON NESTING: PUT A POLYGON IN THE SKY ARRAY.
00200 BEGIN INSKY;------------------------------------------------------
00300
00400 ACCUMULATORS{R,C,R2,C2,E,E2}
00500
00600 DEFINE ADVANCE{
00700 LAC E,E2↔LAC R,R2↔LAC C,C2
00800 CCW E2,E2
00900 ROW R2,E2↔ADDI R2,40↔LSH R2,-6
01000 COL C2,E2↔ADDI C2,40↔LSH C2,-6}
01100
01200 ;XWD HORIZONTAL,,VERTICAL.
01300 LAC 1,ARG1↔SON E,1
01400 DAC E,E0#↔JUMPE E,POP1J.
01500 CW E2,E↔ADVANCE↔ADVANCE↔GO S1
01600
01700 ;SOUTH ↓ BOUND.
01800 S0: CAMN E,E0↔POP1J
01900 S1: LAC E↔XCT GETSKY(R)
02000 SKIPE 1↔TRC %↔XCT PUTSKY(R)
02100 CAIE R2,(R)1↔AOJA R,S1↔ADVANCE
02200 TEST E,EASBIT↔GO W0↔GO EE0
02300
02400 ;NORTH ↑ BOUND.
02500 N0: SOS R
02600 N1: LAC E↔XCT GETSKY(R)
02700 SKIPE 1↔TRC %↔XCT PUTSKY(R)
02800 CAME R,R2↔SOJA R,N1↔ADVANCE
02900 TEST E,EASBIT↔GO W0↔GO EE0
03000
03100 ;EAST → BOUND.
03200 EE0: ADVANCE
03300 TEST E,NORBIT↔GO S0↔GO N0
03400
03500 ;WEST ← BOUND.
03600 W0: ADVANCE
03700 TEST E,NORBIT↔GO S0↔GO N0
03800
03900 BEND INSKY;BGB 7 DECEMBER 1972 -----------------------------------
00100 SUBR(KILVIC)LEVEL. KILL: CONTOURS OF THE PREVIOUS LEVEL.
00200 BEGIN KILVIC;-----------------------------------------------------
00300 ACCUMULATORS{PG,E0,E1,E2,PG0}
00400 SKIPN ESMOO↔POP1J
00500 LAC 1,ARG1↔CW 1,1
00600 SON PG,1
00700 SKIPN PG0,PG↔POP1J
00800
00900 ;RELEASE VIC NODES OF THE POLYGON.
01000 L1: SON E0,PG
01100 TESTZ E0,ARCBIT↔GO L3
01200 ARC 0,PG↔SON. 0,PG
01300 SETZ↔ARC. 0,PG
01400 LAC E1,E0
01500 L2: CCW E2,E1
01600 SETZ↔SON 1,E1↔SKIPE 1↔SON. 0,1
01700 CALL(KLNODD,E1)
01800 CAMN E2,E0↔GO L3
01900 LAC E1,E2↔GO L2
02000
02100 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02200 L3: CCW PG,PG
02300 CAME PG,PG0↔GO L1
02400 POP1J
02500
02600 BEND KILVIC; BGB 5 JANUARY 1973 ----------------------------------
00100 SUBR(KLBABY)LEVEL KILL: BABY POLYGONS OF A LEVEL.
00200 BEGIN KLBABY;-----------------------------------------------------
00300 ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
00400 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#
00500 ;KLUDGE - SPARE SON POLYGON UNTIL WE CAN THINK OF A POLICY.
00600 GO L3
00700 ;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
00800 L1: NCNT 0,PG↔LACM
00900 CAIL =10↔GO L3
01000
01100 ;RELEASE VIC NODES OF THE POLYGON.
01200 SON E0,PG
01300 LAC E1,E0
01400 L2: CCW E2,E1
01500 CALL(KLNODD,E1)
01600 CAMN E2,E0↔GO .+3
01700 LAC E1,E2↔GO L2
01800
01900 ;KILL A BABY POLYGON.
02000 CAR Q,(PG)↔CDR R,(PG)
02100 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02200 CALL(KLNODD,PG)
02300 SKIPA PG,R ;CCW FROM OUT OF THE GRAVE.
02400
02500 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02600 L3: CCW PG,PG↔CAME PG,PG0↔GO L1
02700 POP1J
02800
02900 BEND;1/6/73------------------------------------------------------
00100 SUBR(KLPGON)PGN KILL: POLYGON AND RETURN CCW(PGN).
00200 BEGIN KLPGON;-----------------------------------------------------
00300 ACCUMULATORS{PG,E0,E1,E2,Q,R}
00400 LAC PG,ARG1
00500
00600 ;RELEASE VIC NODES OF THE POLYGON.
00700
00800 SON E0,PG
00900 LAC E1,E0
01000 L1: CCW E2,E1
01100 CALL(KLNODD,E1)
01200 CAMN E2,E0↔GO .+3
01300 LAC E1,E2↔GO L1
01400
01500 ;RING OUT & KILL POLYGON NODE,
01600
01700 NGON Q,PG↔PGON R,PG↔JUMPE R,L2
01800 NGON. Q,R↔PGON. R,Q↔CAMN PG,R↔SETZ R,
01900 EXO 1,PG↔JUMPE 1,.+4↔ENDO 0,1↔CAMN 0,PG↔ENDO. R,1
02000 ENDO 1,PG↔SKIPE 1↔ZIP 3(1) ;MY ENDO BECOMES AN ORPHAN.
02100
02200 L2: CAR Q,(PG)↔CDR R,(PG)
02300 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02400 CALL(KLNODD,PG)
02500
02600 ;DOES DAD NEED A NEW FIRST SON.
02700
02800 DAD 1,R
02900 CAMN PG,R↔SETZ R,
03000 SON 0,1↔CAMN 0,PG↔SON. R,1
03100
03200 ;RETURN PGON CCW FROM OUT OF THE GRAVE.
03300 LAC 1,R
03400 POP1J
03500
03600 BEND KLPGON;BGB 1 JANUARY 1973 ----------------------------------
00100 SUBR(SMOOTH)LEVEL SMOOTH: CONTOURS INTO ARCS.
00200 BEGIN SMOOTH;-----------------------------------------------------
00300
00400 ACCUMULATORS{V1,V2,PG,E0,E1,E2}
00500 SKIPN ESMOO↔POP1J
00600 LAC 1,ARG1
00700 SON PG,1↔SKIPN PG↔POP1J
00800
00900 ;POLYGON INITIALIZATION.
01000
01100 L1: DAC PG,PGSAVE#
01200 SON V1,PG↔DAC V1,E0SAVE# ;UPPER MOST LEFT VERTEX.
01300 ARC V2,PG ;LOWER MOST RIGHT VERTEX.
01400 TESTZ V2,ARCBIT↔POP1J ;END OF LEVEL'S POLYGON RING.
01500
01600 ;CREATE ARC NODES AT POLYGON'S EXTREME CORNERS.
01700
01800 SETQ(ARC2,{MKNODD,[VBIT+ARCBIT+VREL]})
01900 LAC RC(V2)↔DAC RC(1)↔SON. 1,V2↔SON. V2,1
02000 SETQ(ARC1,{MKNODD,[VBIT+ARCBIT+VREL]})
02100 LAC RC(V1)↔DAC RC(1)↔SON. 1,V1↔SON. V1,1
02200
02300 LAC 2,ARC2↔CCW. 1,2↔CW. 1,2↔CCW. 2,1↔CW. 2,1
02400 DAD. PG,1↔DAD. PG,2↔ARC. 1,PG
02500
02600 ;CALL FOR CREATION OF THE INTERMEDIATE ARC NODES.
02700 DZM AVCNT
02800 CALL(MKARCS,ARC1,ARC2)
02900 CALL(MKARCS,ARC2,ARC1)
03000
03100 ;KILL TWO-SIDED ARC-POLYGONS AND ADVANCE TO NEXT POLYGON.
03200 SKIPN AVCNT↔GO[
03300 L2: CALL(KLNODD,ARC1)
03400 CALL(KLNODD,ARC2)
03500 SETQ(PG,{KLPGON,PGSAVE})
03600 JUMPN PG,L1↔POP1J]
03700 LAC PG,PGSAVE↔CCW PG,PG↔GO L1
03800
03900 LIT
04000 DECLARE{ARC1,ARC2}
04100 BEND SMOOTH; BGB 6 DECEMBER 1972 ---------------------------------
04200
04300 DECLARE{AVCNT} ;ARC-VERTEX COUNT.
00100 ;MKARCS(V1,V2). SMOOTH: MAKE ARCS FROM V1 CCW TO V2.
00200 SUBR(MKARCS)V1,V2-------------------------------------------------
00300 BEGIN MKARCS
00400 ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
00500 LAC V1,ARG2↔LAC V2,ARG1
00600 ;CHECK FOR TRIVAIL CASE.
00700 L0: SON U1,V1↔SON U2,V2
00800 CCW 0,U1↔CAMN 0,U2↔GO L3
00900
01000 ;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01100 ROW A,V1↔FLO A, ; A ← Y1.
01200 COL B,V2↔FLO B, ; B ← X2.
01300 COL C,V1↔FLO C, ; C ← X1.
01400 ROW D,V2↔FLO D, ; D ← Y2.
01500 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
01600 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
01700 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
01800 LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
01900 CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
02000 LAC 0,A↔FMPR 0,A↔HLLM 0,6(V1)
02100 LAC 0,B↔FMPR 0,B↔HLRM 0,6(V1)
02200
02300 ;SET 'EM UP FOR AN ARC PASS.
02400 SON U1,V1↔SON U2,V2
02500 DZM DMAX#↔DZM DMIN#
02600 DZM VMAX#↔DZM VMIN#↔DZM MAXCON#
02700 ;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
02800 L1: CCW U1,U1↔CAMN U1,U2↔GO L2
02900 COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
03000 FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
03100 CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
03200 CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
03300 ;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
03400 CNTRST 0,V1↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
03500
03600 ;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
03700 L2: LAC U,VMIN↔LACM DMIN
03800 CAMGE DMAX↔LAC U,VMAX
03900 CAMGE DMAX↔LAC DMAX
04000 LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
04100 ;OLDE ESPLIT.
04200 SETQ(V,{MKNODD,[VBIT+ARCBIT+VREL]})↔AOS AVCNT
04300 SON. U,V↔SON. V,U
04400 LAC RC(U)↔DAC RC(V)↔DAD 0,U↔DAD. 0,V
04500 CCW. V,V1↔CW. V1,V
04600 CCW. V2,V↔CW. V,V2
04700 LAC V2,V↔GO L0
04800 ;ADVANCE CCW AN ARC-EDGE OR EXIT.
04900 L3: CAMN V2,ARG1↔POP2J
05000 LAC V1,V2↔CCW V2,V2↔GO L0
05100 BEND MKARCS; BGB 28 DECEMBER 1972 --------------------------------
00100 SUBR(HISTOG) MISC: MAKE HISTOGRAM OF TVBUF.
00200 BEGIN HISTOG;--------------------------------------------------
00300 SKIPE FLGHIS↔POP0J↔SETOM FLGHIS
00400 LAC[XWD HISTO,HISTO+1]
00500 DZM HISTO↔BLT HISTO+77
00600 LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00700
00800 ;ACCUMULATOR LOOP.
00900 L: =62208 ;0
01000 0 ;1
01100 ILDB 1,6 ;2
01200 AOS HISTO(1) ;3
01300 SOJG 0,2 ;4
01400 POP0J ;5
01500 POINT 6,TVBUF,-1;6
01600
01700 BEND HISTOG; BGB 4 DECEMBER 1972 ---------------------------------
01800 END